home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / MISCMYFI.INC < prev    next >
Text File  |  1994-02-18  |  10KB  |  364 lines
  1.  
  2.  
  3. Function MyOpenFileExisting(var fvar : file; fname : string;
  4.                 recsize, fmode : integer; var error : integer) : boolean;
  5.      begin
  6.      MyOpenFileExisting := false;
  7.      if not FileExists(fname) then
  8.           begin
  9.           writeln('File not found [',fname,']');
  10.           exit;
  11.           end;
  12.     { writeln('file found [',fname,']');}
  13.      FileMode := fmode;
  14.      assign(fvar,fname);
  15. {$I-} reset(fvar,recsize); {$I+}
  16.      error := IOResult;
  17.      if error <> 0 then
  18.           begin
  19.           writeln('Unable to open file [',fname,']  error=',error);
  20.           exit;
  21.           end;
  22.      MyOpenFileExisting := true;
  23.      end;
  24.  
  25.  
  26.  
  27. Function MyOpenFileCreate(var fvar : file; fname : string;
  28.                             recsize : integer; var error : integer) : boolean;
  29. { MUST NOT exist already }
  30.      begin
  31.      MyOpenFileCreate := false;
  32.      if FileExists(fname) then
  33.           begin
  34.           writeln('Error - File already exists [',fname,']');
  35.           exit;
  36.           end;
  37.     { writeln('file not found [',fname,']');}
  38.      FileMode := 2;
  39.      assign(fvar,fname);
  40. {$I-} rewrite(fvar,recsize); {$I+}
  41.      error := IOResult;
  42.      if error <> 0 then
  43.           begin
  44.           writeln('Unable to create file [',fname,']  error=',error);
  45.           exit;
  46.           end;
  47.      MyOpenFileCreate := true;
  48.      end;
  49.  
  50.  
  51. Function MyBlockRead(var fvar : file; var buf; count : integer;
  52.                      var numread, error : integer) : boolean;
  53. var mycount : integer;
  54.     mybuf : array[1..4096] of char;
  55.      begin
  56.      MyBlockRead := false;
  57.      error := 0;
  58.      mycount := min(count,sizeof(mybuf));
  59.      fillchar(mybuf,mycount,0);
  60. {$I-} blockread(fvar,mybuf,mycount,numread); {$I+}
  61.      error := IOResult;
  62.      if (error <> 0) then
  63.           begin
  64.           writeln('MyBlockRead error=',error, '  numread=',numread);
  65.           exit;
  66.           end;
  67.      move(mybuf,buf,numread);
  68.      MyBlockRead := true;
  69.      end;
  70.  
  71.  
  72. Function MyBlockWrite(var fvar : file; var buf; count : integer;
  73.                      var numwritten,error : integer) : boolean;
  74.      begin
  75.      MyBlockWrite := false;
  76.      error := 0;
  77.      numwritten := 0;
  78. {$I-} blockwrite(fvar,buf,count,numwritten); {$I+}
  79.      error := IOResult;
  80.      if (error <> 0) then
  81.           begin
  82.           writeln('MyBlockWrite error=',error,'   numwritten=',numwritten);
  83.           exit;
  84.           end;
  85.      MyBlockwrite := true;
  86.      end;
  87.  
  88.  
  89. Function MyCloseFile(var fvar : file; var error : integer) : boolean;
  90.      begin
  91.      MyCloseFile := false;
  92.      error := 0;
  93. {$I-} Close(fvar); {$I+}
  94.      error := IOResult;
  95.      if (error <> 0) then
  96.           begin
  97.           writeln('MyCloseFile error=',error);
  98.           exit;
  99.           end;
  100.      MyCloseFile := true;
  101.      end;
  102.  
  103.  
  104. Function MySeek(var fvar : file; n : longint; var error : integer) : boolean;
  105.      begin
  106.      MySeek := false;
  107.      error := 0;
  108. {$I-} Seek(fvar,n); {$I+}
  109.      error := IOResult;
  110.      if (error <> 0) then
  111.           begin
  112.           writeln('MySeek error=',error);
  113.           exit;
  114.           end;
  115.      MySeek := true;
  116.      end;
  117.  
  118.  
  119.  
  120. {SECTION  TextPos }
  121. {Note: code uses a 'TEXTREC' type  which must be in DOS (check it out)}
  122.  
  123. type wordrec = record low,high:word; end;
  124.  
  125. Function actualfilepos(var f:text):longint;
  126. var reg         : registers;
  127.     templong    : longint;
  128.      begin
  129.      with reg do
  130.           begin
  131.           ah := $42;
  132.           al := 1;
  133.           bx := textrec(f).handle;
  134.           cx := 0;
  135.           dx := 0;
  136.           msdos(reg);
  137.           wordrec(templong).high := dx;
  138.           wordrec(templong).low := ax;
  139.           end;
  140.      actualfilepos := templong;
  141.      end;
  142.  
  143.  
  144. Function TextPos(var f:text):longint;
  145.      begin
  146. {     TextPos := actualfilepos(f) - textrec(f).bufsize + textrec(f).bufpos;
  147.   Cantlon's algorithm didn't work for the first buffer - hnr 12/90
  148.   this algorithm works fine for sequential file reading, but putting in
  149.   a textseek screws this up.  Maybe fix it later. 1/94 hnr
  150. }
  151. {     writeln('TextPos   actual=',(actualfilepos(f)-1),
  152.                     '  bufsize=',textrec(f).bufsize,
  153.                     '  bufpos=',textrec(f).bufpos);  }
  154.  
  155.      TextPos := (((actualfilepos(f)-1) div textrec(f).bufsize) *
  156.                          textrec(f).bufsize)    + textrec(f).bufpos;
  157.      end;
  158.  
  159.  
  160.  
  161. {SECTION  TextSeek }
  162. {* TurboPower equivalent calls, so I don't have to change code *}
  163. {Note: code uses a 'TEXTREC' type  which must be in DOS (check it out)}
  164.  
  165. Function TextSeek(var f:text; n:longint) : boolean;
  166. var reg         : registers;
  167.     c           : char;
  168.      begin
  169.      if n < 0 then n := 0;
  170.      with reg do
  171.           begin
  172.           ah := $42;
  173.           al := 0;
  174.           bx := textrec(f).handle;
  175.           cx := wordrec(n).high;
  176.           dx := wordrec(n).low;
  177.           msdos(reg);
  178.           end;
  179.      textrec(f).bufpos := textrec(f).bufend;
  180.      read(f,c);
  181.      textrec(f).bufpos := 0;
  182.      TextSeek := true;  { have to figure out error return - hnr 12/90}
  183.                         { seek past eof is error }
  184.      end;
  185.  
  186.  
  187.  
  188. {SECTION  FmtFileInfo  }
  189. Function  FmtFileInfo(fname,ext : string) : string;
  190.                     {[FILE] gets info and formats it}
  191. var SR : searchrec;
  192.      begin
  193.      fileinfo(fname,ext,SR);
  194.      FmtFileInfo := FmtSearchRec(SR);
  195.      end;
  196.  
  197.  
  198.  
  199. {SECTION FmtSearchRec }
  200. Function FmtSearchRec(SR : SearchRec) : string;
  201. var s : string[35];
  202.     dt : datetime;
  203.     i : integer;
  204.      begin
  205.      s := leftstr(SR.name,12);
  206.      i := 13; replacestr(s,i,longintstr(SR.size,8));
  207.      i := 23; replacestr(s,i,leftstr(FmtPTimeStr(SR.time),14));
  208.      FmtSearchRec := s;
  209.      end;
  210.  
  211.  
  212. {SECTION FmtSearchRecK   }
  213. Function FmtSearchRecK(SR : SearchRec) : string;
  214. var s : string[35];
  215.     dt : datetime;
  216.     i : integer;
  217.      begin
  218.      s := leftstr(SR.name,12);
  219.      if SR.size < 2048 then SR.size := 2048;
  220.      i := 13; replacestr(s,i,rightstr(FmtKstrComma((SR.size)),7));
  221.      i := 22; replacestr(s,i,leftstr(FmtPTimeStr(SR.time),14));
  222.      FmtSearchRecK := s;
  223.      end;
  224.  
  225.  
  226. {SECTION  FullFmtFileInfo  }
  227. Function  FullFmtFileInfo(fname,ext : string; p : pathstr) : string;
  228.                     {[FILE] gets info and formats it(FULL PATH)}
  229. var fn : string;
  230.     SR : searchrec;
  231.      begin
  232.      fn := fname;
  233.      fn := addbackslash(p)+fn;
  234.      fileinfo(fn,ext,SR);
  235.      FullFmtFileInfo := FullFmtSearchRec(SR,p);
  236.      end;
  237.  
  238.  
  239. {SECTION  FullFmtSearchRec }
  240. Function  FullFmtSearchRec(SR : SearchRec; p : pathstr) : string;
  241. var s,s1 : string;
  242.      begin
  243.      s1 := FmtSearchRec(SR);
  244.      delete(s1,1,12);
  245.      s := p + SR.name;
  246.      replacestr(s,40,' '+s1);
  247.      FullFmtSearchRec := s;
  248.      end;
  249.  
  250.  
  251. {SECTION  FullFmtSearchRecK  }
  252. Function  FullFmtSearchRecK(SR : SearchRec; p : pathstr) : string;
  253. var s,s1 : string;
  254.      begin
  255.      s1 := FmtSearchRecK(SR);
  256.      delete(s1,1,12);
  257.      s := p + SR.name;
  258.      replacestr(s,40,' '+s1);
  259.      FullFmtSearchRecK := s;
  260.      end;
  261.  
  262.  
  263. {SECTION  SearchEngine }
  264. { hnr note - started with anonymous pd code called ENGINE
  265.              obtained from EMS shareware
  266.  
  267.  SEARCH ENGINE
  268.         Input Parameters:
  269.               Mask  : The file specification to search for
  270.                       May contain wildcards
  271.               Attr  : File attribute to search for
  272.               Proc  : Procedure to process each found file
  273.  
  274.         Output Parameters:
  275.               ErrorCode  : Contains the final error code.
  276. }
  277.  
  278. VAR EngineMask : FSCAN_FullNameStr;
  279.     EngineAttr : Byte;
  280.     EngineProc : FSCAN_ProcType;
  281.     EngineCode : Byte;
  282.  
  283.  
  284. Procedure SearchEngine(Mask : PathStr; Attr : Byte; Proc : FSCAN_ProcType;
  285.                        VAR ErrorCode : Byte);
  286. VAR S : SearchRec;
  287.     P : PathStr;
  288.     Ext : ExtStr;
  289.  
  290.      begin
  291.      FSplit(Mask, P, Mask, Ext);
  292.      Mask := Mask + Ext;
  293.      FindFirst(P + Mask, Attr, S);
  294.      if DosError <> 0 then
  295.           begin
  296.           ErrorCode := DosError;
  297.           Exit;
  298.           end;
  299.  
  300.      while DosError = 0 do
  301.           begin
  302.           Proc(S, P);
  303.           FindNext(S);
  304.           end;
  305.      if DosError = 18 then ErrorCode := 0
  306.      ELSE ErrorCode := DosError;
  307.      end;
  308.  
  309.  
  310. {SECTION  SearchEngineAll  }
  311. Procedure SearchEngineAll(path : PathStr; Mask : FSCAN_FullNameStr; Attr : Byte;
  312.                           Proc : FSCAN_ProcType; VAR ErrorCode : Byte);
  313.  
  314.      begin
  315.      (* Set up Unit global variables for use in recursive directory search Procedure *)
  316.      EngineMask := Mask;
  317.      EngineProc := Proc;
  318.      EngineAttr := Attr;
  319.      SearchEngine(path + Mask, Attr, Proc, ErrorCode);
  320.      SearchEngine(path + '*.*', Directory OR Attr, SESearchOneDir, ErrorCode);
  321.      ErrorCode := EngineCode;
  322.      end;
  323.  
  324.  
  325. {SECTION  SESearchOneDir  }
  326. {$F+}
  327. Procedure SESearchOneDir(VAR S : SearchRec; P : PathStr);
  328. {$F-}                        {Recursive Procedure to search one directory}
  329.      begin
  330.      if SEGoodDirectory(S) then
  331.           begin
  332.           P := P + S.name;
  333.           SearchEngine(P + '\' + EngineMask, EngineAttr, EngineProc, EngineCode);
  334.           SearchEngine(P + '\*.*',Directory OR Archive, SESearchOneDir, EngineCode);
  335.           end;
  336.      end;
  337.  
  338.  
  339. {SECTION  SEErrorMessage  }
  340. Procedure SEErrorMessage(ErrCode : Byte);
  341.      begin
  342.      CASE ErrCode OF
  343.           0    : ;                              {OK -- no error}
  344.           2    : WriteLn(' 2 File not found');
  345.           3    : WriteLn(' 3 Path not found');
  346.           5    : WriteLn(' 5 Access denied');
  347.           6    : WriteLn(' 6 Invalid handle');
  348.           8    : WriteLn(' 8 Not enough memory');
  349.           10   : WriteLn(' 10 Invalid environment');
  350.           11   : WriteLn(' 11 Invalid format');
  351.           18   : ;                              {OK -- merely no more files}
  352.           ELSE WriteLN('ERROR #', ErrCode);
  353.           end;
  354.      end;
  355.  
  356.  
  357.  
  358. {SECTION  SEGoodDirectory }
  359. Function  SEGoodDirectory(S : SearchRec) : Boolean;
  360.      begin
  361.      SEGoodDirectory := (S.name <> '.') AND (S.name <> '..') AND
  362.                       (S.Attr AND Directory = Directory);
  363.      end;
  364.